home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / rbtree < prev    next >
Text File  |  1993-02-18  |  14KB  |  361 lines
  1. ;;;; Copyright (C) 1990 Patrick G. Solbavarro.    -*-Scheme-*-
  2. ;;;; Red-black trees as in "Introduction to Algorithms," by Cormen, Leiserson,
  3. ;;;; and Rivest, chapter 15.
  4.  
  5. ;;;; PGS, 6 Jul 1990
  6. ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93
  7.  
  8. (require 'record)
  9. (define rb-tree
  10.   (make-record-type
  11.    "rb-tree"
  12.    '(root left-rotation-field-maintainer right-rotation-field-maintainer
  13.       insertion-field-maintainer deletion-field-maintainer
  14.       prior?)))
  15.  
  16. (define make-rb-tree
  17.   (let ((mrb (record-constructor rb-tree)))
  18.     (lambda (left-rotation-field-maintainer
  19.          right-rotation-field-maintainer
  20.          insertion-field-maintainer
  21.          deletion-field-maintainer
  22.          prior?)
  23.       (mrb #f left-rotation-field-maintainer right-rotation-field-maintainer
  24.        insertion-field-maintainer deletion-field-maintainer
  25.        prior?))))
  26.  
  27. (define rb-tree-root (record-accessor rb-tree 'root))
  28. (define set-rb-tree-root! (record-modifier rb-tree 'root))
  29. (define rb-tree-left-rotation-field-maintainer
  30.   (record-accessor rb-tree 'left-rotation-field-maintainer))
  31. (define rb-tree-right-rotation-field-maintainer
  32.   (record-accessor rb-tree 'right-rotation-field-maintainer))
  33. (define rb-tree-insertion-field-maintainer
  34.   (record-accessor rb-tree 'insertion-field-maintainer))
  35. (define rb-tree-deletion-field-maintainer
  36.   (record-accessor rb-tree 'deletion-field-maintainer))
  37. (define rb-tree-prior? (record-accessor rb-tree 'prior?))
  38.  
  39. (define rb-node (make-record-type "rb-node" '(left right parent color data)))
  40. (define make-rb-node
  41.   (let ((mrn (record-constructor rb-node)))
  42.     (lambda (data)
  43.       (mrn #f #f #f 'black data))))
  44.  
  45. (define rb-node-left (record-accessor rb-node 'left))
  46. (define set-rb-node-left! (record-modifier rb-node 'left))
  47. (define rb-node-right (record-accessor rb-node 'right))
  48. (define set-rb-node-right! (record-modifier rb-node 'right))
  49. (define rb-node-parent (record-accessor rb-node 'parent))
  50. (define set-rb-node-parent! (record-modifier rb-node 'parent))
  51. (define rb-node-color (record-accessor rb-node 'color))
  52. (define set-rb-node-color! (record-modifier rb-node 'color))
  53. (define rb-node-data (record-accessor rb-node 'data))
  54. (define set-rb-node-data! (record-modifier rb-node 'data))
  55.  
  56. ;;;; Rotations
  57. (define (rb-left-rotate tree x)
  58.   (let ((y (rb-node-right x)))
  59.     (let ((beta (rb-node-left y)))
  60.       (set-rb-node-right! x beta)
  61.       ;; make sure x's new child knows who its parent is
  62.       (if beta (set-rb-node-parent! beta x)))
  63.     ;; y is now x's parent's child
  64.     (let ((subtree-parent (rb-node-parent x)))
  65.       (set-rb-node-parent! y subtree-parent)
  66.       ;; if x was tree root, y is now
  67.       (if (not subtree-parent)
  68.       (set-rb-tree-root! tree y)
  69.       ;; otherwise if x wasn't tree root, have to figure out which child
  70.       ;; it was, so we can update parent's corresponding child field.
  71.       (if (eq? x (rb-node-left subtree-parent))
  72.           (set-rb-node-left! subtree-parent y)
  73.           (set-rb-node-right! subtree-parent y))))
  74.     ;; now x is y's left child
  75.     (set-rb-node-left! y x)
  76.     ;; and y is x's parent
  77.     (set-rb-node-parent! x y)
  78.     ;; invoke augmented field maintenance routine if there is one
  79.     (let ((augmented-field-maintenance-routine
  80.        (rb-tree-left-rotation-field-maintainer tree)))
  81.       (if augmented-field-maintenance-routine
  82.       (augmented-field-maintenance-routine x y)))))
  83.  
  84. (define (rb-right-rotate tree y)
  85.   (let ((x (rb-node-left y)))
  86.     (let ((beta (rb-node-right x)))
  87.       (set-rb-node-left! y beta)
  88.       ;; make sure y's new child knows who its parent is
  89.       (if beta (set-rb-node-parent! beta y)))
  90.     ;; x is now y's parent's child
  91.     (let ((subtree-parent (rb-node-parent y)))
  92.       (set-rb-node-parent! x subtree-parent)
  93.       ;; if y was tree root, x is now
  94.       (if (not subtree-parent)
  95.       (set-rb-tree-root! tree x)
  96.       ;; otherwise if y wasn't tree root, have to figure out which child
  97.       ;; it was, so we can update parent's corresponding child field.
  98.       (if (eq? y (rb-node-right subtree-parent))
  99.           (set-rb-node-right! subtree-parent x)
  100.           (set-rb-node-left! subtree-parent x))))
  101.     ;; now y is x's right child
  102.     (set-rb-node-right! x y)
  103.     ;; and x is y's parent
  104.     (set-rb-node-parent! y x)
  105.     ;; invoke augmented field maintenance routine if there is one
  106.     (let ((augmented-field-maintenance-routine
  107.        (rb-tree-right-rotation-field-maintainer tree)))
  108.       (if augmented-field-maintenance-routine
  109.       (augmented-field-maintenance-routine x y)))))
  110.  
  111.  
  112. ;;;; Insertion.
  113.  
  114. (define (rb-insert! tree x)
  115.   ;; normal binary tree insertion
  116.   (define (rb-binary-tree-insert tree z)
  117.     (let ((prior? (rb-tree-prior? tree))
  118.       (y #f)
  119.       (z-data (rb-node-data z)))
  120.       (do ((x (rb-tree-root tree)))
  121.       ((not x))
  122.     (set! y x)
  123.     (if (prior? z-data (rb-node-data x))
  124.         ;; descend left
  125.         (set! x (rb-node-left x))
  126.         ;; descend right
  127.         (set! x (rb-node-right x))))
  128.       ;; link z in under y
  129.       (set-rb-node-parent! z y)
  130.       ;; if y was null, z is now the root of the tree
  131.       (if (not y)
  132.       (set-rb-tree-root! tree z)
  133.       ;; but otherwise have to make z appropriate child of y
  134.       (if (prior? z-data (rb-node-data y))
  135.           (set-rb-node-left! y z)
  136.           (set-rb-node-right! y z)))))
  137.   ;; start by doing normal binary tree insertion
  138.   (rb-binary-tree-insert tree x)
  139.   (let ((augmented-field-maintenance-routine
  140.      (rb-tree-insertion-field-maintainer tree)))
  141.     (if augmented-field-maintenance-routine
  142.     (augmented-field-maintenance-routine x)))
  143.   (set-rb-node-color! x 'red)
  144.   (do ((y 'uninitialized))
  145.       ((or (eq? x (rb-tree-root tree))
  146.        (not (eq? (rb-node-color (rb-node-parent x)) 'red))))
  147.     ;; if x's parent is a left child of its grandparent
  148.     (if (eq? (rb-node-parent x)
  149.          (rb-node-left (rb-node-parent (rb-node-parent x))))
  150.     (begin
  151.       ;; get other child of x's grandparent
  152.       (set! y (rb-node-right (rb-node-parent (rb-node-parent x))))
  153.       ;; if uncle was red
  154.       (if (and y (eq? (rb-node-color y) 'red))
  155.           ;; making grandparent red, maintain lower invariants
  156.           (begin
  157.         (set-rb-node-color! (rb-node-parent x) 'black)
  158.         (set-rb-node-color! y 'black)
  159.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  160.         (set! x (rb-node-parent (rb-node-parent x))))
  161.           ;; if uncle was black,
  162.           (begin
  163.         ;; if x is a right child,
  164.         (cond ((eq? x (rb-node-right (rb-node-parent x)))
  165.                ;; left-rotate about parent
  166.                (set! x (rb-node-parent x))
  167.                (rb-left-rotate tree x)))
  168.         (set-rb-node-color! (rb-node-parent x) 'black)
  169.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  170.         (rb-right-rotate tree (rb-node-parent (rb-node-parent x))))))
  171.     ;; if x's parent is a right child of its grandparent
  172.     (begin
  173.       ;; get other child of x's grandparent
  174.       (set! y (rb-node-left (rb-node-parent (rb-node-parent x))))
  175.       ;; if uncle was red
  176.       (if (and y (eq? (rb-node-color y) 'red))
  177.           ;; making grandparent red, maintain lower invariants
  178.           (begin
  179.         (set-rb-node-color! (rb-node-parent x) 'black)
  180.         (set-rb-node-color! y 'black)
  181.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  182.         (set! x (rb-node-parent (rb-node-parent x))))
  183.           (begin
  184.         ;; if x is a left child,
  185.         (cond ((eq? x (rb-node-left (rb-node-parent x)))
  186.                ;; right-rotate about parent
  187.                (set! x (rb-node-parent x))
  188.                (rb-right-rotate tree x)))
  189.         (set-rb-node-color! (rb-node-parent x) 'black)
  190.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  191.         (rb-left-rotate tree (rb-node-parent (rb-node-parent x))))))))
  192.   (set-rb-node-color! (rb-tree-root tree) 'black))
  193.  
  194. ;;;; Queries
  195. (define (rb-node-minimum node)
  196.   (let ((node-left (rb-node-left node)))
  197.     (if node-left
  198.     (rb-node-minimum node-left)
  199.     node)))
  200.  
  201. (define (rb-node-maximum node)
  202.   (let ((node-right (rb-node-right node)))
  203.     (if node-right
  204.     (rb-node-maximum node-right)
  205.     node)))
  206.  
  207.  
  208. (define (rb-tree-minimum tree)
  209.   (rb-node-minimum (rb-tree-root tree)))
  210.  
  211. (define (rb-tree-maximum tree)
  212.   (rb-node-maximum (rb-tree-root tree)))
  213.  
  214. (define (rb-node-successor x)
  215.   (let ((node-right (rb-node-right x)))
  216.     (if node-right (rb-node-minimum node-right)
  217.     (do ((y (rb-node-parent x)))
  218.         ((or (not y) (not (eq? x (rb-node-right y))))
  219.          y)
  220.       (set! x y)
  221.       (set! y (rb-node-parent y))))))
  222.  
  223. (define (rb-node-predecessor x)
  224.   (if (rb-node-left x) (rb-node-minimum (rb-node-left x))
  225.       (do ((y (rb-node-parent x)))
  226.       ((or (not y) (not (eq? x (rb-node-left y))))
  227.        y)
  228.     (set! x y)
  229.     (set! y (rb-node-parent y)))))
  230.  
  231.  
  232. ;;;; Deletion.  We do not entirely follow Cormen, Leiserson and Rivest's lead
  233. ;;;; here, because their use of sentinels is in rather obscenely poor taste.
  234. ;;;; Instead, we pass X's parent to RB-DELETE-FIXUP and check explicitly for
  235. ;;;; the null case.
  236.  
  237. ;;; The node that is actually deleted may not be the one passed in, so if a
  238. ;;; resource is being maintained, what should be put back on the freelist is
  239. ;;; the node returned by this procedure.
  240. (define (rb-delete! tree z)
  241.   ;; first part is usual binary tree deletion
  242.   (let* ((y 'uninitialized)
  243.      (x 'uninitialized))
  244.     (if (or (not (rb-node-left z)) (not (rb-node-right z)))
  245.     ;; if node to delete has only one child or none, can just splice it
  246.     ;; out
  247.     (set! y z)
  248.     ;; if node to delete has two children, find its successor (which has
  249.     ;; only one child) and splice successor in in place of deleted node
  250.     (set! y (rb-node-successor z)))
  251.     ;; know at this point that y has at most one child; get it in x
  252.     (if (rb-node-left y)
  253.     (set! x (rb-node-left y))
  254.     (set! x (rb-node-right y)))
  255.     ;; we'll want this later
  256.     (let ((y-parent (rb-node-parent y)))
  257.       ;; this child takes y's place.
  258.       (if x (set-rb-node-parent! x (rb-node-parent y)))
  259.       ;; if y was the root, have to update the tree
  260.       (if (not y-parent)
  261.       (set-rb-tree-root! tree x)
  262.       ;; if y wasn't root, have to tell y's parent about new child x
  263.       (if (eq? y (rb-node-left y-parent))
  264.           (set-rb-node-left! y-parent x)
  265.           (set-rb-node-right! y-parent x)))
  266.       (let ((deletion-field-maintenance-routine
  267.          (rb-tree-deletion-field-maintainer tree))
  268.         (insertion-field-maintenance-routine
  269.          (rb-tree-insertion-field-maintainer tree)))
  270.     ;; if we have a deletion field maintainer, use it to make tree
  271.     ;; consistent with y's removal.
  272.     (if deletion-field-maintenance-routine
  273.         (deletion-field-maintenance-routine y))
  274.     ;; if y was actually z's successor, we aren't really deleting y but z,
  275.     ;; and inserting y in z's place.  So update z's data field to y's.
  276.     (cond ((not (eq? y z))
  277.            (cond (deletion-field-maintenance-routine
  278.               (deletion-field-maintenance-routine z) ;deleting z
  279.               (insertion-field-maintenance-routine y))) ;inserting y
  280.            (set-rb-node-data! z (rb-node-data y)))))
  281.       ;; clean up tree if we've unbalanced it
  282.       (if (eq? (rb-node-color y) 'black)
  283.       (rb-delete-fixup tree x y-parent)))
  284.     y))
  285.  
  286. ;;; This routine makes the red-black tree a legal red-black tree again.  At
  287. ;;; entry, X is a node that is "doubly black."  X-PARENT is passed in case X
  288. ;;; is actually null.
  289. (define (rb-delete-fixup tree x x-parent)
  290.   (do ((w 'uninitialized))
  291.       ;; done when x is root or no longer black
  292.       ((or (eq? x (rb-tree-root tree))
  293.        (not (or (not x)        ;x is black if x is null
  294.             (eq? (rb-node-color x) 'black)))))
  295.     (if (eq? x (rb-node-left x-parent))
  296.     ;; note that w cannot be NIL, by red-black tree invariants, because
  297.     ;; x is doubly black, and otherwise the black-counts on the branches
  298.     ;; would be different.
  299.     (begin (set! w (rb-node-right x-parent))
  300.            ;; if w is red make it black and rotate
  301.            (cond ((eq? (rb-node-color w) 'red)
  302.               (set-rb-node-color! w 'black)
  303.               (set-rb-node-color! x-parent 'red)
  304.               (rb-left-rotate tree x-parent)
  305.               ;; this new w can't be NIL either, by same argument
  306.               (set! w (rb-node-right x-parent))))
  307.            ;; if both of w's children are black
  308.            (if (and (or (not (rb-node-left w))
  309.                 (eq? (rb-node-color (rb-node-left w)) 'black))
  310.             (or (not (rb-node-right w))
  311.                 (eq? (rb-node-color (rb-node-right w)) 'black)))
  312.            (begin (set-rb-node-color! w 'red) ;make w red
  313.               (set! x x-parent) ;move up tree
  314.               (set! x-parent (rb-node-parent x)))
  315.            (begin
  316.              (cond ((or (not (rb-node-right w))
  317.                 (eq? (rb-node-color (rb-node-right w)) 'black))
  318.                 ;; know left isn't NIL, or IF would have succeeded
  319.                 (set-rb-node-color! (rb-node-left w) 'black)
  320.                 (set-rb-node-color! w 'red)
  321.                 (rb-right-rotate tree w)
  322.                 (set! w (rb-node-right x-parent))))
  323.              (set-rb-node-color! w (rb-node-color x-parent))
  324.              (set-rb-node-color! x-parent 'black)
  325.              (if (rb-node-right w)
  326.              (set-rb-node-color! (rb-node-right w) 'black))
  327.              (rb-left-rotate tree x-parent)
  328.              (set! x (rb-tree-root tree)))))
  329.     ;; W can't be NIL here either, as above
  330.     (begin (set! w (rb-node-left x-parent))
  331.            ;; if w is red make it black and rotate
  332.            (cond ((eq? (rb-node-color w) 'red)
  333.               (set-rb-node-color! w 'black)
  334.               (set-rb-node-color! x-parent 'red)
  335.               (rb-right-rotate tree x-parent)
  336.               ;; **are we still okay in referencing x-parent here?
  337.               (set! w (rb-node-left x-parent))))
  338.            ;; if both of w's children are black
  339.            (if (and (or (not (rb-node-right w))
  340.                 (eq? (rb-node-color (rb-node-right w)) 'black))
  341.             (or (not (rb-node-left w))
  342.                 (eq? (rb-node-color (rb-node-left w)) 'black)))
  343.            (begin (set-rb-node-color! w 'red) ;make w red
  344.               (set! x x-parent) ;move up tree
  345.               (set! x-parent (rb-node-parent x)))
  346.            (begin
  347.              (cond ((or (not (rb-node-left w))
  348.                 (eq? (rb-node-color (rb-node-left w)) 'black))
  349.                 ;; know right isn't NIL, or IF would have succeeded
  350.                 (set-rb-node-color! (rb-node-right w) 'black)
  351.                 (set-rb-node-color! w 'red)
  352.                 (rb-left-rotate tree w)
  353.                 (set! w (rb-node-left x-parent))))
  354.              (set-rb-node-color! w (rb-node-color x-parent))
  355.              (set-rb-node-color! x-parent 'black)
  356.              (if (rb-node-left w)
  357.              (set-rb-node-color! (rb-node-left w) 'black))
  358.              (rb-right-rotate tree x-parent)
  359.              (set! x (rb-tree-root tree)))))))
  360.   (if x (set-rb-node-color! x 'black)))
  361.